home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Programming / Programming Languages / Yerk 3.64 ƒ / System source / Menu < prev    next >
Encoding:
Text File  |  1993-05-25  |  8.4 KB  |  271 lines  |  [TEXT/ttxt]
  1. \  5- 7-84  NDI Version 1
  2. \  6/18/84  CBD Added Draw: and clear in MenuBar
  3. \  6/27/84  CBD Separated FILL: from INIT:
  4. \  8/16/84  CBD Non-resource definition
  5. \ 10/25/84  CBD FILL:-> PUT:, SET: -> HILITE:, etc
  6. \ 12/20/84  cbd Added desk accy support
  7. \ 12/20/84  cbd Added menu key support
  8. \ 12/30/85  cdn Expanded AppleMen to handle up to 22 items
  9. \  9/03/86  cdn Added call DrawMenuBar to enable: & disable:
  10. \  9/23/86  cdn Fixed opendesk:, saves graph port
  11. \  9/31/88    rfl    added mItem, changed mselect, key:
  12. \ 10/26/89  rfl    added menuId, more menus in mbar
  13. \                set now consistent with get,check,uncheck
  14. \                All begin with 1.
  15. \  5/13/90    rfl    added ability to add and remove menus in menubar
  16. \  5/23/90    rfl    added hmenu,pmenu,applemenu
  17. \  5/30/90    rfl modified enable, disable menubar to work nicer in display
  18. \ 12/24/90    rfl fixed getName: pmenu
  19. \  5/10/91    rfl added getnew: for use with resource files
  20. \  5/14/91    rfl    addone does not add to menubar if menu already is there
  21. \  2/25/92    rfl    added getName; checkone
  22. \  6/23/92    rfl    removed position: from pmenu; fixed uncheckall:
  23. \  7/19/92    rfl    changed set: to have stack consistent with sarray input to:
  24. \ 11/10/92    rfl changed 'getname: pmenu' to getHItemName, so can use super method
  25. \ 12/21/92    rfl    added ability to determine if an item is checked with checked?: method
  26. \  5/25/93    rfl added remove: to release: and dispose:; release: to getnew: applemen
  27.  
  28. \ ( hndl -- )  error if Toolbox object hasn't called new: or getnew:
  29. : ?new   dup 0= classerr" 153 ;
  30.  
  31. 0 value theMenu    \ the pointer to the selected menu
  32.  
  33. :CLASS Menu  <Super X-Array
  34.  
  35.     Int        Resid    \ Resource ID of this menu
  36.     handle    Mhndl    \ Handle to menu heap storage
  37.  
  38.     \ ( -- resid )
  39.     :M  ID:      Get: Resid     ;M
  40.  
  41.     \ ( resID -- )  store menuID
  42.     :M  INIT:  put: resID  ;M
  43.  
  44.     :M  PUTRESID: put: resID ;M
  45.  
  46.     \ ( cfa0...cfaN resid -- )  put resid and handlers in menu
  47.     :M  PUT:     Put: ResId   Put: Super  ;M
  48.  
  49.     \ ( item# -- addr len )  get string for item #
  50.     :M  GET:  { item -- addr len } get: mhndl  item makeInt
  51.         buf255 +base  call GetItem  buf255 count ;M
  52.  
  53.     :M  GETNAME: ( -- addr len) get: Mhndl >ptr 14 + count ;M
  54.  
  55.     :M  GETNEW: 0 int: ResId call getMenu dup 0= ?error 161 put: mHndl ;M
  56.  
  57.     \ ( addr len -- )  Allocate menu with  Title
  58.     :M  NEW:  str255  >R 0  Int: resId  R> call NewMenu
  59.         Put: Mhndl    ;M
  60.  
  61.     :M  REMOVE: int: resId call deleteMenu ;M
  62.  
  63.     \ ( -- )  Insert the menu in the menu bar
  64.     :M  INSERT:   Get: Mhndl ?new word0 call InsertMenu  ;M
  65.  
  66.     :M  DISPOSE: remove: self get: mHndl call disposMenu clear: mHndl ;M
  67.  
  68.     \ use this if menu read in from resource file instead of dispose:
  69.     :M  RELEASE: remove: self get: mHndl call ReleaseResource clear: mHndl ;M
  70.  
  71.     \ ( addr len -- )  Append a menu item
  72.     :M  ADD:   Str255  Get:  Mhndl ?new
  73.         swap  call AppendMenu  ;M
  74.  
  75.     \ ( type -- )  add all resources of a type
  76.     :M  ADDRES:  get: mhndl swap call AddResMenu  ;M
  77.  
  78.     \ ( addr len item# -- )  replace menu item string
  79.     :M  SET:   >r str255 >r get: mhndl ?new
  80.         r> r> swap >r makeInt r> call SetItem ;M
  81.  
  82.     \ ( -- )  Remove hiliting on all items
  83.     :M  NORMAL:  word0  call HiliteMenu ;M
  84.  
  85.     :M  HILITE: int: resID call hiliteMenu ;M
  86.  
  87.     \ ( item# -- )  Enable a menu item
  88.     :M  ENABLE:  Get: Mhndl over makeInt call EnableItem
  89.         0= IF call DrawMenuBar THEN  ;M
  90.  
  91.     \ ( item# -- )  Grey and disable an item
  92.     :M  DISABLE: Get: Mhndl over makeInt call DisableItem
  93.         0= IF call DrawMenuBar THEN  ;M
  94.  
  95.  
  96.     \ ( item# -- )  open the desk accy for item#
  97.     :M  OPENDESK: savePort get: self 2drop
  98.         word0 buf255 +base call OpenDeskAcc word0 drop restPort  ;M
  99.  
  100.     \ all menu handlers will have item# on stack when they execute
  101.     \ ( item# -- )  Execute the code for a menu item
  102.     :M  EXEC: ^base -> theMenu 1- dup Exec: Super drop  Normal: Self   ;M
  103.  
  104.     \ ( item# -- )
  105.     :M  CHECK:  Get: Mhndl  swap makeInt w 256 call CheckItem  ;M
  106.  
  107.     \ ( item# -- )
  108.     :M  UNCHECK:     Get: Mhndl  swap makeInt word0 call CheckItem  ;M
  109.  
  110.     :M UNCHECKALL: limit 1+ 1 DO i uncheck: self LOOP ;M
  111.     :M CHECKONE: ( n --) uncheckall: self check: self ;M
  112.  
  113.     :M CHECKED?: { mitem \ addr -- b }
  114.         mitem limit > classerr" 129                \ make sure within limits
  115.         get: mhndl >ptr 14 + -> addr            \ move to title field in record
  116.         addr c@ addr + 1+ -> addr                \ move to 1st item pascal string
  117.         mitem 0                                    \ start search for end of mitem string
  118.         DO addr c@ addr + 1+ 4+ -> addr LOOP    \ moves to end of mitem string
  119.         addr 2- c@ 0= IF false ELSE true THEN ;M    \ moves back to check byte
  120.  
  121. ;CLASS
  122.  
  123. :CLASS applemenu <super menu
  124.  
  125.     :M  EXEC: ( item# --) dup 3 <
  126.             IF exec: super ELSE openDesk: super normal: super THEN ;M
  127.  
  128.     :M  GETNEW: release: super getnew: super 'type DRVR  addRes: self ;M
  129.  
  130. ;CLASS
  131.  
  132.  
  133. :CLASS hmenu <super menu
  134.  :M insert: get: mhndl w -1 call insertMenu ;M
  135. ;CLASS
  136.  
  137. 0 value mItem    \ global keeping # of last menu item clicked;start1
  138. 0 value menuID
  139.  
  140. \ ( point -- item# menuID )  call menu manager to track a menu selection
  141. : Mselect 0 swap call MenuSelect unpack swap dup -> mItem swap 
  142.      -> menuID menuID  ;
  143.  
  144.  
  145. \ 3.11.90    rfl    modified getText: for pmenu to support hierarchical. Get: still works
  146. \  The print method for popUpRect always look to the stringvar for printing.
  147. \ it is loaded to the correct string on menu select by the mode value.
  148.  
  149. \ pmenu knows how to popup when asked, and it keeps track of
  150. \    which item was selected, and it allows for an x,y offset
  151. \    for display purposes
  152.  
  153. :CLASS pmenu <super hmenu
  154.  
  155.     int        type        \ 0: 'offset' rel to mouse;1: use 'offset' as absolute
  156.     point    offset        \ if type=0, then MOUSE will be offset from upper left
  157.                         \  corner of menu.
  158.     int        lastPick
  159.  
  160. \ determines if popup appears offset to mouse, or at absolute position
  161.   :M type: ( n --) put: type ;M
  162.  
  163.   :M popup: ( -- )
  164.     0 get: mHndl
  165.     get: type
  166.     IF   int: offset l->g intSwap
  167.     ELSE where: fevent unpack gety: offset - swap getx: offset - pack
  168.     THEN
  169.     int: lastpick   call popupmenuselect
  170.     unpack  -> menuId  -> mitem
  171.     mitem 0 >
  172.     IF get: resid menuId =                            \ is mouse in popUp?
  173.        IF   mitem put: lastPick mitem exec: self    \ yes
  174.        ELSE mitem menuId exec: menubar                \ must be hierarchical submenu
  175.        THEN 
  176.     ELSE 0 -> menuid
  177.     THEN ;M
  178.  
  179. \ this is coded to allow for getting the text item of a hierarchical menu
  180. \ attached to the popup
  181.   :M getText: ( item# -- addr len)
  182.         0 menuId makeInt call getMHandle            \ get menuhandle
  183.         swap 1+ makeint buf255 +base call GetItem    \ get text of selected item
  184.         buf255 count ;M
  185.  
  186.   :M offset: ( x y -- ) put: offset ;M
  187. \  :M position: ( x y -- ) put: self ;M
  188.  
  189.   :M putitem: ( lastPick -- ) put: lastPick ;M
  190.   :M getitem: ( -- lastPick ) get: lastPick ;M
  191.   :M getHItemName: ( -- addr len) get: lastPick 1- getText: self ;M
  192.  
  193. \ inits to relative offset to mouse
  194.   :M classinit: 25 9 offset: self classinit: super ;M
  195.  
  196. ;CLASS
  197.  
  198.  
  199. \ ( item# -- item#)  execute the desk accessory for an item
  200. \ : doDsk  1+ dup openDesk: [ ^base ]  ;
  201.  
  202. 2 applemenu applemen
  203.  
  204.  
  205. :CLASS mBar  <Super Object
  206.  
  207.     26 wordcol    IDs
  208.     26 ordered-col    Menus    \ array of menu objects
  209.  
  210.     \ ( -- )
  211.     :M  DRAW:   call DrawMenuBar     ;M
  212.  
  213.     \ ( -- )
  214.     :M  CLEAR:   call ClearMenuBar  Clear: IDs clear: Menus   ;M
  215.  
  216.     :M  Menu: ( id -- menu t or f) indexof: ids IF at: menus true ELSE false THEN ;M
  217.  
  218.     :M  addone: ( ^menu -- ) dup indexof: Menus not
  219.         IF id: [ dup ] add: ids dup add: menus insert: [ ] draw: self
  220.         ELSE 2drop
  221.         THEN ;M
  222.  
  223.     :M  remove: ( ^menu -- ) remove: [ dup ] indexof: menus
  224.         IF dup remove: menus remove: ids THEN draw: self ;M
  225.  
  226.     \ Add menu objects in stream to the MenuBar object
  227.     \ ( ^men0...^menN  #menus -- )
  228.     :M  ADD:  0
  229.         DO   add: Menus  Id: [ I at: menus ]  Add: IDs
  230.         LOOP  ;M
  231.  
  232.     \ ( -- )  Insert menus in Toolbox MenuBar list
  233.     :M  NEW:    Size: IDs  0
  234.         DO  insert: [ Size: IDs  1- i-  at: Menus ]
  235.         LOOP  Draw: Self   ;M
  236.  
  237.     :M  GETNEW: size: Menus 0 DO getnew: [ i at: Menus ] LOOP ;M
  238.  
  239.     \ ( men0...menN #menus -- )
  240.     :M  INIT:  Clear: self  Add: Self  getnew: self New: self   ;M
  241.  
  242.     \ ( men0...menN #menus -- ) - use with mload module
  243. \    :M  MINIT:  Clear: self  Add: Self  New: self   ;M
  244.  
  245.     \ ( item# MenuID -- )
  246.     :M  EXEC:  dup 0>
  247.         IF   IndexOf:  IDs
  248.             IF  Exec: [ at: Menus ]  THEN
  249.         ELSE  2drop
  250.         THEN   ;M    \ Execute item in menu
  251.  
  252.     \ ( -- )
  253.     :M  CLICK:  Where: fEvent   MSelect  Exec: Self   ;M
  254.  
  255.     \ ( chr -- )   handle a possible menu key selection
  256.     :M  KEY:  0 swap makeInt call MenuKey unpack -> menuID -> mItem
  257.         mItem menuID exec: self   ;M
  258.     
  259.     \ Enable all menus in the Menu Bar
  260.     :M  ENABLE:   Size: IDs 0
  261.         DO I at: menus 2+ @ word0 call enableItem LOOP Draw: Self   ;M
  262.  
  263.     :M  DISABLE:  Size: IDs 0
  264.         DO  i at: Menus 2+ @ word0 call disableItem  LOOP  Draw: Self  ;M
  265.  
  266. ;CLASS
  267.  
  268. \  Define the default menu bar for applications
  269.  mBar MenuBar
  270.  
  271.